Shareware Super Platinum 8

home *** CD-ROM | disk | FTP | other *** search

/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / PROGTOOL / LIB211.ZIP;1 / OBSOLETE.PRG < prev next >

Wrap

Text File | 1993-11-19 | 28.8 KB | 715 lines

*----------------------------------------------------------------------- *-- Program...: OBSOLETE.PRG *-- Programmer: Ken Mayer (CIS: 71333,1030) *-- Date......: 07/29/1993 *-- Notes.....: The following functions are not necessary using dBASE *-- IV, 1.5 (or in some cases, 2.0), but have been retained *-- in the current version of the library system in order *-- to have some compatibility with 1.1. *----------------------------------------------------------------------- FUNCTION Empty *----------------------------------------------------------------------- *-- Programmer..: Jerry Wightman (WIGHTMAN) *-- Date........: ? *-- Notes.......: Used to check whether a memory variable in dBASE *-- contains anything, based on type of field. (Pulled *-- from BORBBS) *-- NOTE: In release 1.5, replace all calls to EMPTY() *-- with the new: ISBLANK() function. This will be *-- faster. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Empty(<cFld>) *-- Example.....: @5,10 say "Enter date: " get bDate; *-- valid required .not. empty(bDate); *-- error chr(7)+"** Date cannot be Empty! **" *-- Returns.....: Logical (.t./.f.) *-- Parameters..: cFld = Field/Memvar/Expression to check for *-- "Emptiness" *----------------------------------------------------------------------- PARAMETERS cFld && may be memory variable or database field name private cTalk, lReturn m->cTalk = SET("TALK") m->lReturn = .F. && FALSE means: variable is NOT empty do case case type( "cFld" ) = "C" if len( ltrim(rtrim( m->cFld )) ) = 0 m->lReturn = .T. endif case type( "cFld" ) = "N" .or. type( "cFld" ) = "F" if m->cFld = 0 m->lReturn = .T. endif case type( "cFld" ) = "L" m->lReturn = .F. && Can't check logical fields case type( "cFld" ) = "D" if m->cFld = {} m->lReturn = .T. endif case type( "cFld" ) = "M" if len( m->cFld ) = 0 m->lReturn = .T. endif otherwise && TYPE = "U" m->lReturn = .T. endcase set talk &cTalk. RETURN m->lReturn *-- EoF: Empty() FUNCTION NumFlds *----------------------------------------------------------------------- *-- Programmer..: Bowen Moursund (CIS: 72662,436) *-- Date........: 07/12/1991 *-- Notes.......: Returns the number of fields in a database structure - *-- only in the currently selected DBF *-- NOTE: In release 1.5, replace function NUMFLDS() with *-- FLDCOUNT() -- built in to 1.5, faster ... *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 07/12/1991 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: NumFlds() *-- Example.....: ? NumFlds() *-- Returns.....: Number of fields *-- Parameters..: None *----------------------------------------------------------------------- private nFlds,cFldName *-- If currently selected database is empty (no dbf file) if len(trim(dbf())) = 0 m->nFlds = 0 && set to 0 *-- we have something ... else m->nFlds = 0 && initialize do while .t. && loop through the record structure m->nFlds= m->nFlds + 1 && increment counter m->cFldName = field(m->nFlds) && get fieldname if len(trim(m->cFldName)) = 0 && if length = 0, m->nFlds = m->nFlds - 1 && decrement counter exit && get out of loop, we're done endif && endif(length...) enddo && end of loop endif RETURN m->nFlds *-- EoF: NumFlds() FUNCTION DateSet *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 03/01/1992 *-- Notes.......: Returns string giving name of current DATE format *-- This is not needed in Version 1.5, in which *-- set("DATE") returns the format. Unlike that function *-- in 1.5, this one cannot distinguish between date *-- formats set with different terms that amount to the *-- same thing: *-- DMY = BRITISH = FRENCH *-- MDY = AMERICAN *-- YMD = JAPAN *-- If your users will be using one of these formats and *-- are sensitive about the name, substitute the one they *-- want for the equivalent in this function. *-- Rev. History: 03/01/1992 -- Original *-- Written for.: dBASE IV, versions below 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: DateSet() *-- Example.....: ?DateSet() *-- Returns.....: Character *-- Parameters..: None *----------------------------------------------------------------------- private cCent, cTestdate, cDelimiter m->cCent = set( "CENTURY" ) set century off m->cTestDate = ctod( "01/02/03" ) m->cDelimiter = substr( dtoc( m->cTestDate ), 3, 1 ) set century &cCent. do case case month( m->cTestDate ) = 1 RETURN iif( m->cDelimiter = "-", "USA", "MDY" ) case day( m->cTestDate ) = 1 RETURN iif( m->cDelimiter = "/", "DMY", ; iif( m->cDelimiter = ".", "GERMAN", "ITALIAN" ) ) otherwise RETURN iif( m->cDelimiter = ".", "ANSI", "YMD" ) endcase *-- EoF: DateSet() FUNCTION Stampval *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 04/07/1992 *-- Notes.......: Passed a 16-character string in the form of the *-- rightmost 16 characters returned by the DOS DIR *-- command for a file, returns a number that will compare *-- properly in date/time order with the numbers returned *-- by this function for other files. *-- Written for.: dBASE IV Versions below 1.5 *-- Rev. History: 04/07/1992 *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Stampval(<cTimestamp>) *-- Example.....: IF Stampval("02-22-92 10:54a") > *-- Stampval("04-05-92 5:54p") *-- Returns.....: Numeric corresponding to time stamp of file *-- Parameters..: cStamp, a DIR timestamp *----------------------------------------------------------------------- parameters cStamp RETURN 1440 * ( 12 * val( left(m->cStamp,2)) + ; val(substr(m->cStamp,4,2)) + 372*val(substr(m->cStamp,7,2)) ); + 60 * val(substr(m->cStamp,11,2)) + ; val(substr(m->cStamp,14,2)) + iif(right(m->cStamp,1)=; "p",720,0) *--Eof() Stampval PROCEDURE FullWin *----------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 05/23/91 *-- Notes.......: Overlays menus or another screen with a full window, *-- so that processing is done in the window, and one can *-- return directly to the menus, without redrawing screen *-- and such. This routine may be a problem in dBASE IV, *-- 1.5 ... use with caution ... *-- NOTE: This routine was removed as completely *-- unnecessary once I familiarized myself with SAVE SCREEN *-- and RESTORE SCREEN ... *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 05/23/1991 *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do fullwin with <cColor>,<cWinName>,<cScreen> *-- Example.....: do fullwin with "w+/b","w_Edit","sc_Main" *-- * perform whatever actions are needed in the window *-- deactivate window wEdit *-- release window wEdit *-- restore screen from sMain *-- release screen sMain *-- Returns.....: None *-- Parameters..: cColor = Colors for window *-- cWinName = Name of window *-- cScreen = Name of screen *----------------------------------------------------------------------- parameters cColor,cWinName,sScreen define window &cWinName. from 0,0 to 23,79 none color &cColor. save screen to &sScreen. activate window &cWinName. RETURN *-- EoP: FullWin ******************************** ** The following color routines ** were "retired" as I found ** better ways of doing things. ******************************** PROCEDURE SetColor *----------------------------------------------------------------------- *-- Programmer..: Phil Steele *-- Date........: 05/23/91 *-- Notes.......: Used to set the screen colors for a system. It *-- checks to see if a color monitor is attached *-- (ISCOLOR()), and sets system variables, that can be *-- used in SET COLOR OF commands. You must define the *-- memvars as PUBLIC, see Example below -- otherwise *-- nothing will work. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: Borrowed from Phil Steele's PCSDEMO (a public domain *-- program) and commented a bit more, minor modifications *-- by Ken Mayer *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do setcolor *-- Example.....: in a menu or setup program: *-- PUBLIC cl_blank,cl_func,cl_help,cl_data,cl_error,; *-- cl_entry,cl_stand,cl_menu,cl_warn *-- DO setcolor *-- by declaring the variables PUBLIC before calling *-- SETCOLOR they should be globally available *-- throughout, unless you use a CLEAR ALL or RELEASE *-- ALL command ... *-- Returns.....: None *-- Parameters..: None *----------------------------------------------------------------------- if file("COLOR.MEM") restore from Color.mem additive && if color.mem exists, && restore from it else && otherwise, create it m->lC = iscolor() && remember -- foreground/background m->cl_Blank = "n/n,n/n,n" && black on black on black ... m->cl_Func = "n/w" && function keys (used in CLRSHOW) * if iscolor() = true, define color, otherwise black/white m->cl_Help = iif(m->lC,"n/g,g/n,n" , "w+/n,n/w,n") m->cl_Data = iif(m->lC,"rg+/gb,gb/rg,n" , "n/w,w+/n,n") m->cl_Error = iif(m->lC,"rg+/r,w/n,n" , "w+/n,n/w,n") m->cl_Entry = iif(m->lC,"n/w,w/n,n" , "n/w,w/n,n") m->cl_Stand = iif(m->lC,"w+/b,b/w,n" , "w+/n,n/w,n") m->cl_Menu = iif(m->lC,"rg+/b,b/w,n" , "w+/n,n/w,n") m->cl_Warn = iif(m->lC,"rg+/r,w/n,n" , "w/n,n/w,n") save to color all like cl_* && create COLOR.MEM endif *-- change current color settings to these ... set color to &cl_stand. cTemp = extrclr(m->cl_Data) set color of fields to &cTemp. set color of messages to &cTemp. set color of box to &cTemp. cTemp = extrclr(m->cl_Stand) set color of highlight to &cTemp. RETURN *-- EoP: SetColor PROCEDURE SetColor2 *----------------------------------------------------------------------- *-- Programmer..: Phil Steele *-- Date........: 05/23/91 *-- Notes.......: Used to set the screen colors for a system. It *-- checks a parameter passed by the programmer to see if *-- the monitor is a color system. It then creates the *-- proper color combinations based on this ... *-- Written for.: dBASE IV, 1.1 *-- Rev. History: Borrowed from Phil Steele's PCSDEMO (a public domain *-- program) and commented a bit more, minor modifications *-- by Ken Mayer 11/21/91 -- Modified for parameter ... *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do setcolor2 with "<cYN>" *-- Example.....: in a menu or setup program: *-- PUBLIC cl_blank,cl_func,cl_help,cl_data,cl_error,; *-- cl_entry,cl_stand,cl_menu,cl_warn *-- DO setcolor2 with "Y" *-- by declaring the variables PUBLIC before calling *-- SETCOLOR2 they should be globally available *-- throughout, unless you use a CLEAR ALL or RELEASE *-- ALL command ... *-- Returns.....: None *-- Parameters..: cYN = "Y" for color, "N" for mono ... *----------------------------------------------------------------------- parameter cYN private lC, cTemp m->lC = iif(cYN="Y",.t.,.f.) && remember -- foreground/background m->cl_Blank = "n/n,n/n,n" && black on black on black ... m->cl_Func = "n/w" && function keys m->cl_Help = iif(m->lC,"n/g,g/n,n" , "w+/n,n/w,n") m->cl_Data = iif(m->lC,"rg+/gb,gb/rg,n" , "n/w,w+/n,n") m->cl_Error = iif(m->lC,"rg+/r,w/n,n" , "w+/n,n/w,n") m->cl_Entry = iif(m->lC,"n/w,w/n,n" , "n/w,w/n,n") m->cl_Stand = iif(m->lC,"w+/b,b/w,n" , "w+/n,n/w,n") m->cl_Menu = iif(m->lC,"rg+/b,b/w,n" , "w+/n,n/w,n") m->cl_Warn = iif(m->lC,"rg+/r,w/n,n" , "w/n,n/w,n") save to color all like cl_* && create COLOR.MEM *-- change current color settings to these ... set color to &cl_stand. cTemp = extrclr(m->cl_data) set color of fields to &cTemp. set color of messages to &cTemp. set color of box to &cTemp. cTemp = extrclr(m->cl_stand) set color of highlight to &cTemp. RETURN *-- EoP: SetColor2 FUNCTION ExtrClr *----------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 05/24/1991 *-- Notes.......: Used to extract the first parameter of the MEMVARS *-- created from SETCOLOR above. The SET COLOR OF commands *-- can only use the first parameter. *-- It is recommended that you run SetColor (above) first, *-- although if you define your own color memvars, this *-- will work just as well. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 05/24/1991 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: extrclr(<cMemVar>) *-- Example.....: set color of highlight to &extrclr(cl_stand) *-- Returns.....: "W+/B" *-- Parameters..: cMemVar = color memory variable to have colors *-- extracted from *----------------------------------------------------------------------- parameters cMemVar RETURN substr(m->cMemVar,1,(at(",",m->cMemVar)-1)) *-- EoF: ExtrClr() FUNCTION InvClr *----------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 05/23/1991 *-- Notes.......: Used to set an inverse color, using value(s) returned *-- from extrclr above, or from a single color memvar. *-- Inverted colors may give odd results -- RG+ (yellow) *-- is not a background color, for example, and will *-- appear as RG (brown) -- this may not be what you *-- wanted ... *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 05/23/1991 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: invclr(<cMemVar>) *-- Example.....: set color of highlight to &invclr(extrclr(cl_stand)) *-- or *-- x = extrclr(cl_stand) *-- set color of highlight to &invclr(x) *-- Returns.....: "B/W+" *-- Parameters..: cMemVar = color variable containing colors to be *-- inverted *----------------------------------------------------------------------- parameters cMemVar private cTemp1, cTemp2 m->cTemp1 = substr(m->cMemVar,1,(at("/",m->cMemVar)-1)) m->cTemp2 = substr(m->cMemVar,(at("/",m->cMemVar)+1),len(m->cMemVar)) RETURN m->cTemp2+"/"+m->cTemp1 *-- EoF: InvClr() ********************************************************************** ***** THE FOLLOWING WERE MOVED HERE FROM OTHER LIBRARY FILES FOLLOWING ***** THE RELEASE OF dBASE IV, 2.0. KJM ********************************************************************** FUNCTION Rat *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 03/01/1992 *-- Notes.......: Reverse "at", returns position a character string is *-- last AT in a larger string. *-- Written for.: dBASE IV *-- Rev. History: 03/01/1992 -- Original Release *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Rat("<cFindStr>","<cBigStr>") *-- Example.....: ? Rat("Test","This is a Test string, with Test data") *-- Returns.....: Numeric value *-- Parameters..: cFindStr = string to find in cBigStr *-- cBigStr = string to look in *----------------------------------------------------------------------- parameters cFindstr, cBigstr private nPos,nLen m->nLen = len( m->cFindStr ) m->nPos = len( m->cBigStr ) - m->nLen + 1 do while m->nPos > 0 if substr( m->cBigStr, m->nPos, m->nLen ) = m->cFindStr exit else m->nPos = m->nPos - 1 endif enddo RETURN max( m->nPos, 0 ) *-- EoF: RAt() FUNCTION IsMouse *----------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 06/18/1992 *-- Notes.......: This is used to determine the presence of a mouse *-- driver. Returns a .t. if a mouse driver is detected, *-- a .f. otherwise. This routine will turn the mouse off, *-- automatically. This can be used to detect a mouse, and *-- turn it off, as well as to set a memvar to determine *-- the current mouse state. For example, after running *-- this routine, the mouse will be off (if there's a *-- driver). *-- ****************************** *-- **** REQUIRES JPMOUSE.BIN **** *-- ****************************** *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/18/1992 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: IsMouse() *-- Example.....: ?IsMouse() *-- Returns.....: Logical *-- Parameters..: None *----------------------------------------------------------------------- private cRetVal, lIsMouse, X Load JPMOUSE.BIN m->cRetVal = call("JPMOUSE","?") m->lIsMouse = iif(m->cRetVal="T",.t.,.f.) if m->lIsMouse x = call("JPMOUSE","H") endif release module JPMOUSE RETURN m->lIsMouse *-- EoF: IsMouse() PROCEDURE SetMouse *----------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 06/18/1992 *-- Notes.......: This is used to determine the presence of a mouse *-- driver, and/or turn the mouse cursor off in dBASE IV, *-- 1.5 *-- ****************************** *-- **** Requires JPMOUSE.BIN **** *-- ****************************** *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/18/1992 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Do SetMouse with <c_Mouse> *-- Example.....: PUBLIC c_Mouse *-- x=ismouse() && function in MISC.PRG *-- store "OFF" to c_Mouse && after calling IsMouse() *-- && it's 'Off' *-- ON KEY LABEL Alt-M DO SetMouse *-- Returns.....: .T. *-- Parameters..: c_Mouse = A GLOBAL memory variable -- this can/will *-- be changed by this procedure to the opposite *-- scenario when the routine is called. The *-- concept here is to switch the mouse on *-- and/or off if there's a mouse driver. *-- This memvar should be set to the current status of *-- the mouse- if on, it should hold "ON" in it ... *----------------------------------------------------------------------- private X if type("m->c_Mouse") # "C" && if c_Mouse has not been defined as return && a character field, return endif load JPMOUSE.BIN && load the module *-- if the mouse is off, we're going to set it on ("S"), if on, we're *-- going to set it off "H") m->cSetMouse = iif(upper(m->c_Mouse) = "OFF","S","H") m->x=call("JPMOUSE",m->cSetMouse) release module JPMOUSE && remove from memory *-- if c_Mouse was 'off' we are setting it 'on', and vice versa m->c_Mouse = iif(upper(m->c_Mouse) = "OFF","ON","OFF") && change state of c_Mouse RETURN *-- EoP: SetMouse FUNCTION IsUnique ********************************************************************* ** ** WARNING WARNING WARNING ** ** Extensive testing has shown that this routine causes problems in ** dBASE IV, 1.5 and later. Use SEEK() or SEEK instead, to determine ** uniqueness (if FOUND() and all that ...) ** In Version 2.0, use KEYMATCH() ********************************************************************** *----------------------------------------------------------------------- *-- Programmer..: Clinton L. Warren (VBCES) *-- Date........: 04/28/1992 *-- Notes.......: Checks to see if an index key already exists in the *-- current selected database. This function was inspired *-- by Tom Woodward's Chk4Dup UDF. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: May 15, 1991 Version 1.1 Added check for zero record *-- database *-- May 7, 1991 Version 1.0 Initial 'release'. *-- 04/28/1992 -- modified for dBASE IV, 1.5 due to 'new' *-- behavior (see READ.ME that comes with 1.5). Should *-- function fine with 1.1 and 1.0. This change from David *-- Love (DAVIDLOVE). *-- NOTE: NEW PARAMETER *-- Calls.......: None *-- Called by...: Any *-- Usage.......: IsUnique(<xValue>,"<cOrder>","<cField>") *-- Example.....: @5,5 SAY "SSN: " GET SSN PICTURE "999-99-9999"; *-- valid required IsUnique(SSN, "SSN", "SSN"); *-- message "Enter a new SSN"; *-- error chr(7)+"SSN must be unique!" *-- Returns.....: .T./.F. *-- Parameters..: xValue = Value (any non-memo type) to check for *-- uniqueness *-- cOrder = MDX Tag used to order the database. Must be *-- set for field being checked. *-- cField = field name for 'get'. *----------------------------------------------------------------------- parameters xValue, cOrder, cField private nRecNo, nRecCnt, cSetNear, cSetDel, lIsDeleted, cSetOrder private lIsUnique m->nRecNo = recno() && store current record number m->nRecCnt = reccount() && count records in database if m->nRecCnt = 0 && empty database, cValue MUST be unique RETURN .t. endif m->cSetNear = set('NEAR') && store status of NEAR flag set near off && set it off m->cSetDel = set('DELETE') && store status of DELETE set delete on && Delete must be ON for this to work m->lIsDeleted = deleted() && is current record deleted? delete && set delete flag for current record m->cSetOrder = order() && store current MDX tag set order to (m->cOrder) && set tag to that sent to function if seek(m->xValue) && does it exist already? m->lIsUnique = .f. && if so, it's not unique else && otherwise, m->lIsUnique = .t. && it is. endif set order to (cSetOrder) && restore changed settings to && original settings set delete &cSetDel. set near &cSetNear. if m->nRecNo > m->nRecCnt && if called during an append go bottom && goto the bottom of the database, skip 1 && plus one record (the new one) if m->lIsUnique && this is the new part ... replace &cField. with m->xValue endif else go m->nRecNo && otherwise, goto the current record && number endif if .not. m->lIsDeleted && was record 'deleted' before? recall && if not, undelete it ... (turn flag off) endif RETURN (m->lIsUnique) *-- EoF: IsUnique() FUNCTION Delay *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 03/01/1992 *-- Notes.......: Delay Loop. Returns .T. after lapse of given number *-- of seconds. Accurate to one second. For dBASE IV *-- 2.0, use the upgraded version in Time.prg. *-- This may be used in conjunction with EXACTIME.BIN or a *-- similar routine that obtains the tick count. In that *-- case, the delay may be made accurate to one tick. *-- To use it this way, add: *-- LOAD Exactime *-- Arg = space(11) *-- and substitute for each call of the time() function: *-- call( "Exactime", Arg ) *-- *-- Written for.: dBASE IV, Versions below 2.0 *-- Rev. History: 03/01/1992 -- Original function *-- 04/20/1993 -- modified to deal with fractions, bug *-- fixed *-- Calls.......: TIME2SEC() Function in TIME.PRG *-- Called by...: Any *-- Usage.......: Delay(<nSeconds>) *-- Example.....: lX= Delay(10.25) *-- Returns.....: Logical *-- Parameters..: nSeconds = number of seconds to delay *----------------------------------------------------------------------- parameters nSeconds && up to 86400, one day private nTimeout, nTimenow, lRollover m->nTimeOut = 100 * ( Time2Sec( time() ) + m->nSeconds ) if m->nTimeOut > 8640000 m->lRollOVer = .T. m->nTimeOut = m->nTimeOut - 8640000 else m->lRollOVer = .F. endif do while .T. m->nTimeNow = 100 * Time2Sec( time() ) if m->nTimeNow < m->nTimeOut m->lRollOVer = .F. else if .not. m->lRollOVer exit endif endif enddo RETURN .T. *-- EoF: Delay() FUNCTION DateSet *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 03/01/1992 *-- Notes.......: Returns string giving name of current DATE format *-- This is not needed in Version 1.5, where set("DATE") *-- returns the format. Unlike that function in 1.5, this *-- one cannot distinguish between date formats set with *-- different terms that amount to the same thing: *-- DMY = BRITISH = FRENCH *-- MDY = AMERICAN *-- YMD = JAPAN *-- If your users will be using one of these formats and *-- are sensitive about the name, substitute the one they *-- want for the equivalent returned by this function. *-- Rev. History: 03/01/1992 -- Original Release *-- Written for.: dBASE IV, versions below 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: DateSet() *-- Example.....: ?DateSet() *-- Returns.....: Character *-- Parameters..: None *----------------------------------------------------------------------- private cCent, cTestdate, cDelimiter m->cCent = set( "CENTURY" ) set century off m->cTestdate = ctod( "01/02/03" ) m->cDelimiter = substr( dtoc( m->cTestdate ), 3, 1 ) set century &cCent. do case case month( m->cTestdate ) = 1 RETURN iif( m->cDelimiter = "-", "USA", "MDY" ) case day( m->cTestdate ) = 1 RETURN iif( m->cDelimiter = "/", "DMY", ; iif( m->cDelimiter = ".", "GERMAN", "ITALIAN" ) ) otherwise RETURN iif( m->cDelimiter = ".", "ANSI", "YMD" ) endcase *-- EoF: DateSet() *----------------------------------------------------------------------- *-- End of Program: OBSOLETE.PRG *-----------------------------------------------------------------------